home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / nan_news / toolkit / metaph.prg < prev    next >
Text File  |  1991-08-15  |  15KB  |  394 lines
  1. /*
  2.  * File......: METAPH.PRG
  3.  * Author....: Dave Adams
  4.  * Date......: $Date:   15 Aug 1991 23:04:00  $
  5.  * Revision..: $Revision:   1.2  $
  6.  * Log file..: $Logfile:   E:/nanfor/src/metaph.prv  $
  7.  * 
  8.  * This is an original work by Dave Adams and is placed in the
  9.  * public domain.
  10.  *
  11.  * Modification history:
  12.  * ---------------------
  13.  *
  14.  * $Log:   E:/nanfor/src/metaph.prv  $
  15.  * 
  16.  *    Rev 1.2   15 Aug 1991 23:04:00   GLENN
  17.  * Forest Belt proofread/edited/cleaned up doc
  18.  * 
  19.  *    Rev 1.1   14 Jun 1991 19:52:20   GLENN
  20.  * Minor edit to file header
  21.  * 
  22.  *    Rev 1.0   01 Apr 1991 01:01:44   GLENN
  23.  * Nanforum Toolkit
  24.  *
  25.  */
  26.  
  27.  
  28. /*  $DOC$
  29.  *  $FUNCNAME$
  30.  *     FT_METAPH()
  31.  *  $CATEGORY$
  32.  *     String
  33.  *  $ONELINER$
  34.  *     Convert a character string to MetaPhone format
  35.  *  $SYNTAX$
  36.  *     FT_METAPH( <cName> [, <nSize> ] ) -> cMetaPhone
  37.  *  $ARGUMENTS$
  38.  *     <cName> is the character string to convert
  39.  
  40.  *     <nSize> is the length of the character string to be returned.
  41.  *             If not specified the default length is 4 bytes.
  42.  *  $RETURNS$
  43.  *     A phonetically spelled character string
  44.  *  $DESCRIPTION$
  45.  *     This function is a character function use to index and search for
  46.  *     sound-alike or phonetic matches.  It is an alternative to 
  47.  *     the SOUNDEX() function, and addresses some basic pronunciation
  48.  *     rules, by looking at surrounding letters to determine how parts of
  49.  *     the string are pronounced.  FT_METAPH() will group sound-alikes
  50.  *     together, and forgive shortcomings in spelling ability.
  51.  *  $EXAMPLES$
  52.  *     USE Persons
  53.  *     INDEX ON FT_METAPH( LastName ) TO LastName
  54.  *     SEEK FT_METAPH( "Philmore" )
  55.  *     ? FOUND(), LastName             // Result: .T. Philmore
  56.  *     SEEK FT_METAPH( "Fillmore" )
  57.  *     ? FOUND(), LastName             // Result: .T. Philmore
  58.  *  $END$
  59.  */
  60.  
  61. /*
  62.  * File Contents
  63.  * 
  64.  *   FT_METAPH()      Calculates the metaphone of a name
  65.  *   _ftMakeAlpha()   Removes non-alpha characters from a string
  66.  *   _ftConvVowel()   Converts all vowels to the letter 'v'
  67.  *
  68.  *
  69.  * Commentary
  70.  *
  71.  *  The concepts for this algoritm were adapted from an article in the
  72.  *  Computer Language Magazine (Dec.90, Vol.7, No.12) written by
  73.  *  Lawrence B.F. Phillips.
  74.  *
  75.  *  The STRTRAN function was selected to calculate the MetaPhone, to
  76.  *  allow the algoritm to be fine-tuned in an easy manner, as there are
  77.  *  always exceptions to any phonetic pronunciation in not only English,
  78.  *  but many other languages as well.
  79.  *
  80.  *  What is a metaphone?
  81.  *  Basically it takes a character string, removes the vowels, and equates
  82.  *  letters (or groups of letters) to other consonent sounds.  The vowels
  83.  *  are not removed until near the end, as they play an important part
  84.  *  in determining how some consonents sound in different surroundings.
  85.  *
  86.  *  The consonant sounds are:  B, F, H, J, K, L, M, N, P, R, S, T, W, X, Y, 0
  87.  *  Vowels are only included if they are at the beginning.
  88.  *  Here are the transformations. The order of evaluation is important
  89.  *  as characters may meet more than one transformation conditions.
  90.  *  ( note: v = vowel )
  91.  *
  92.  *    B --> B  unless at end of a word after 'm' as in dumb.
  93.  *    C --> X  (sh)  CIA, TCH, CH, ISCH, CC
  94.  *           S  SCI, SCE, SCY, CI, CE, CY
  95.  *           K  otherwise ( including CK )
  96.  *    D --> J  DGE, DGY, DGI
  97.  *           T  otherwise
  98.  *    F --> F
  99.  *    G --> K  GHv, vGHT
  100.  *           W  vGH
  101.  *           J  DGE, DGY, DGI, GI, GE, GY
  102.  *           N  GN
  103.  *           K  otherwise
  104.  *    H --> H  vHv
  105.  *              otherwise silent
  106.  *    J --> J
  107.  *    K --> K
  108.  *    L --> L
  109.  *    M --> M
  110.  *    N --> N
  111.  *    P --> F  PH
  112.  *           P  otherwise
  113.  *    Q --> K
  114.  *    R --> R
  115.  *    S --> X  (sh) SH, SIO, SIA, ISCH
  116.  *           S  otherwise
  117.  *    T --> X  (sh) TIA, TIO, TCH
  118.  *           0  (th) TH
  119.  *           T  otherwise
  120.  *    V --> F
  121.  *    W --> W
  122.  *    X --> KS
  123.  *    Y -->    vY
  124.  *           Y  otherwise
  125.  *    Z --> S
  126.  *
  127.  */
  128.  
  129. *------------------------------------------------
  130. //  Demo of FT_METAPH()
  131.  
  132. //  #define FT_TEST .T.
  133.  
  134. #IFDEF FT_TEST
  135.   FUNCTION MAIN()
  136.   LOCAL cJunk  := SPACE( 8000 )
  137.   LOCAL aNames := {}
  138.   LOCAL cName, nElem
  139.  
  140.   SET( _SET_SCOREBOARD, .F.   )
  141.   SET( _SET_COLOR,      "W/B" )
  142.   CLS
  143.  
  144.   //  Demo will create an array of names and display in 3 columns
  145.   //  _ftRow() and _ftCol() will calculate the screen co-ordinates
  146.   //  by evaluating the element number
  147.  
  148.   AADD( aNames, "Adams"        )
  149.   AADD( aNames, "Addams"       )
  150.   AADD( aNames, "Atoms"        )
  151.   AADD( aNames, "Adamson"      )
  152.   AADD( aNames, "Cajun"        )
  153.   AADD( aNames, "Cagen"        )
  154.   AADD( aNames, "Cochy"        )
  155.   AADD( aNames, "Cocci"        )
  156.   AADD( aNames, "Smith"        )
  157.   AADD( aNames, "Smythe"       )
  158.   AADD( aNames, "Naylor"       )
  159.   AADD( aNames, "Nailer"       )
  160.   AADD( aNames, "Holberry"     )
  161.   AADD( aNames, "Wholebary"    )
  162.   AADD( aNames, "Jackson"      )
  163.   AADD( aNames, "Jekksen"      )
  164.   AADD( aNames, "The Source"   )
  165.   AADD( aNames, "The Sores"    )
  166.   AADD( aNames, "Jones"        )
  167.   AADD( aNames, "Johns"        )
  168.   AADD( aNames, "Lennon"       )
  169.   AADD( aNames, "Lenin"        )
  170.   AADD( aNames, "Fischer"      )
  171.   AADD( aNames, "Fisher"       )
  172.   AADD( aNames, "O'Donnell"    )
  173.   AADD( aNames, "O Donald"     )
  174.   AADD( aNames, "Pugh"         )
  175.   AADD( aNames, "Pew"          )
  176.   AADD( aNames, "Heimendinger" )
  177.   AADD( aNames, "Hymendinker"  )
  178.   AADD( aNames, "Knight"       )
  179.   AADD( aNames, "Nite"         )
  180.   AADD( aNames, "Lamb"         )
  181.   AADD( aNames, "Lamb Chops"   )
  182.   AADD( aNames, "Stephens"     )
  183.   AADD( aNames, "Stevens"      )
  184.   AADD( aNames, "Neilson"      )
  185.   AADD( aNames, "Nelson"       )
  186.   AADD( aNames, "Tchaikovski"  )
  187.   AADD( aNames, "Chikofski"    )
  188.   AADD( aNames, "Caton"        )
  189.   AADD( aNames, "Wright"       )
  190.   AADD( aNames, "Write"        )
  191.   AADD( aNames, "Right"        )
  192.   AADD( aNames, "Manual"       )
  193.   AADD( aNames, "Now"          )
  194.   AADD( aNames, "Wheatabix"    )
  195.   AADD( aNames, "Science"      )
  196.   AADD( aNames, "Cinzano"      )
  197.   AADD( aNames, "Lucy"         )
  198.   AADD( aNames, "Reece"        )
  199.   AADD( aNames, "Righetti"     )
  200.   AADD( aNames, "Oppermann"    )
  201.   AADD( aNames, "Bookkeeper"   )
  202.   AADD( aNames, "McGill"       )
  203.   AADD( aNames, "Magic"        )
  204.   AADD( aNames, "McLean"       )
  205.   AADD( aNames, "McLane"       )
  206.   AADD( aNames, "Maclean"      )
  207.   AADD( aNames, "Exxon"        )
  208.  
  209.   // display names and metaphones in 3 columns on screen
  210.   AEVAL( aNames, ;
  211.          { | cName, nElem | ;
  212.              SETPOS( _ftRow( nElem ), _ftCol( nElem ) ), ;
  213.              QQOUT( PadR( cName, 18, "." ) + FT_METAPH( cName ) ) ;
  214.          } )
  215.  
  216.   SETPOS( 21, 00 )
  217.   QUIT
  218.  
  219.   *------------------------------------------------
  220.   STATIC FUNCTION _ftRow( nElem )  //  Determine which row to print on
  221.   RETURN IIF( nElem > 40, nElem - 40, IIF( nElem > 20, nElem - 20, nElem ) )
  222.   *------------------------------------------------
  223.   STATIC FUNCTION _ftCol( nElem )  //  Determine which column to start print
  224.   RETURN IIF( nElem > 40,  55, IIF( nElem > 20, 28, 1 ) )
  225.   *------------------------------------------------
  226.  
  227. #endif
  228. // End of Test program
  229.  
  230. *------------------------------------------------
  231. FUNCTION FT_METAPH ( cName, nSize )
  232. //  Calculates the metaphone of a character string
  233.  
  234. LOCAL cMeta
  235.  
  236. cName := IIF( cName == NIL, "", cName )  //  catch-all
  237. nSize := IIF( nSize == NIL, 4,  nSize )  //  default size: 4-bytes
  238.  
  239. //  Remove non-alpha characters and make upper case.
  240. //  The string is padded with 1 space at the beginning & end.
  241. //  Spaces, if present inside the string, are not removed until all
  242. //  the prefix/suffix checking has been completed.
  243. cMeta := " " + _ftMakeAlpha( UPPER( ALLTRIM( cName ) ) ) + " "
  244.  
  245. //  prefixes which need special consideration
  246. IF " KN"   $ cMeta ;  cMeta := STRTRAN( cMeta, " KN" , " N"  ) ;  ENDIF
  247. IF " GN"   $ cMeta ;  cMeta := STRTRAN( cMeta, " GN" , " N"  ) ;  ENDIF
  248. IF " PN"   $ cMeta ;  cMeta := STRTRAN( cMeta, " PN" , " N"  ) ;  ENDIF
  249. IF " AE"   $ cMeta ;  cMeta := STRTRAN( cMeta, " AE" , " E"  ) ;  ENDIF
  250. IF " X"    $ cMeta ;  cMeta := STRTRAN( cMeta, " X"  , " S"  ) ;  ENDIF
  251. IF " WR"   $ cMeta ;  cMeta := STRTRAN( cMeta, " WR" , " R"  ) ;  ENDIF
  252. IF " WHO"  $ cMeta ;  cMeta := STRTRAN( cMeta, " WHO", " H"  ) ;  ENDIF
  253. IF " WH"   $ cMeta ;  cMeta := STRTRAN( cMeta, " WH" , " W"  ) ;  ENDIF
  254. IF " MCG"  $ cMeta ;  cMeta := STRTRAN( cMeta, " MCG", " MK" ) ;  ENDIF
  255. IF " MC"   $ cMeta ;  cMeta := STRTRAN( cMeta, " MC" , " MK" ) ;  ENDIF
  256. IF " MACG" $ cMeta ;  cMeta := STRTRAN( cMeta, " MACG"," MK" ) ;  ENDIF
  257. IF " MAC"  $ cMeta ;  cMeta := STRTRAN( cMeta, " MAC", " MK" ) ;  ENDIF
  258. IF " GI"   $ cMeta ;  cMeta := STRTRAN( cMeta, " GI",  " K"  ) ;  ENDIF
  259.  
  260. //  Suffixes which need special consideration
  261. IF "MB " $ cMeta ;  cMeta := STRTRAN( cMeta, "MB " , "M " ) ;  ENDIF
  262. IF "NG " $ cMeta ;  cMeta := STRTRAN( cMeta, "NG " , "N " ) ;  ENDIF
  263.  
  264. //  Remove inner spaces (1st and last byte are spaces)
  265. IF " " $ SUBSTR( cMeta, 2, LEN( cMeta ) - 2 )
  266.   cMeta := " " + STRTRAN( cMeta, " " , "" ) + " "
  267. ENDIF
  268.  
  269. //  Double consonants sound much the same as singles
  270. IF "BB"  $ cMeta ;  cMeta := STRTRAN( cMeta, "BB"  , "B"  ) ;  ENDIF
  271. IF "CC"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CC"  , "CH" ) ;  ENDIF
  272. IF "DD"  $ cMeta ;  cMeta := STRTRAN( cMeta, "DD"  , "T"  ) ;  ENDIF
  273. IF "FF"  $ cMeta ;  cMeta := STRTRAN( cMeta, "FF"  , "F"  ) ;  ENDIF
  274. IF "GG"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GG"  , "K"  ) ;  ENDIF
  275. IF "KK"  $ cMeta ;  cMeta := STRTRAN( cMeta, "KK"  , "K"  ) ;  ENDIF
  276. IF "LL"  $ cMeta ;  cMeta := STRTRAN( cMeta, "LL"  , "L"  ) ;  ENDIF
  277. IF "MM"  $ cMeta ;  cMeta := STRTRAN( cMeta, "MM"  , "M"  ) ;  ENDIF
  278. IF "NN"  $ cMeta ;  cMeta := STRTRAN( cMeta, "NN"  , "N"  ) ;  ENDIF
  279. IF "PP"  $ cMeta ;  cMeta := STRTRAN( cMeta, "PP"  , "P"  ) ;  ENDIF
  280. IF "RR"  $ cMeta ;  cMeta := STRTRAN( cMeta, "RR"  , "R"  ) ;  ENDIF
  281. IF "SS"  $ cMeta ;  cMeta := STRTRAN( cMeta, "SS"  , "S"  ) ;  ENDIF
  282. IF "TT"  $ cMeta ;  cMeta := STRTRAN( cMeta, "TT"  , "T"  ) ;  ENDIF
  283. IF "XX"  $ cMeta ;  cMeta := STRTRAN( cMeta, "XX"  , "KS" ) ;  ENDIF
  284. IF "ZZ"  $ cMeta ;  cMeta := STRTRAN( cMeta, "ZZ"  , "S"  ) ;  ENDIF
  285.  
  286. //  J sounds
  287. IF "DGE" $ cMeta ;  cMeta := STRTRAN( cMeta, "DGE" , "J"  ) ;  ENDIF
  288. IF "DGY" $ cMeta ;  cMeta := STRTRAN( cMeta, "DGY" , "J"  ) ;  ENDIF
  289. IF "DGI" $ cMeta ;  cMeta := STRTRAN( cMeta, "DGI" , "J"  ) ;  ENDIF
  290. IF "GI"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GI"  , "J"  ) ;  ENDIF
  291. IF "GE"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GE"  , "J"  ) ;  ENDIF
  292. IF "GY"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GY"  , "J"  ) ;  ENDIF
  293.  
  294. //  X sounds (KS)
  295. IF "X"   $ cMeta ;  cMeta := STRTRAN( cMeta, "X"   , "KS" ) ;  ENDIF
  296.  
  297. // special consideration for SCH
  298. IF "ISCH" $ cMeta;  cMeta := STRTRAN( cMeta, "ISCH", "IX" ) ;  ENDIF
  299. IF "SCH" $ cMeta ;  cMeta := STRTRAN( cMeta, "SCH" , "SK" ) ;  ENDIF
  300.  
  301. //  sh sounds (X)
  302. IF "CIA" $ cMeta ;  cMeta := STRTRAN( cMeta, "CIA" , "X"  ) ;  ENDIF
  303. IF "SIO" $ cMeta ;  cMeta := STRTRAN( cMeta, "SIO" , "X"  ) ;  ENDIF
  304. IF "C"   $ cMeta ;  cMeta := STRTRAN( cMeta, "SIA" , "X"  ) ;  ENDIF
  305. IF "SH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "SH"  , "X"  ) ;  ENDIF
  306. IF "TIA" $ cMeta ;  cMeta := STRTRAN( cMeta, "TIA" , "X"  ) ;  ENDIF
  307. IF "TIO" $ cMeta ;  cMeta := STRTRAN( cMeta, "TIO" , "X"  ) ;  ENDIF
  308. IF "TCH" $ cMeta ;  cMeta := STRTRAN( cMeta, "TCH" , "X"  ) ;  ENDIF
  309. IF "CH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CH"  , "X"  ) ;  ENDIF
  310.  
  311. //  hissing sounds (S)
  312. IF "SCI" $ cMeta ;  cMeta := STRTRAN( cMeta, "SCI" , "S"  ) ;  ENDIF
  313. IF "SCE" $ cMeta ;  cMeta := STRTRAN( cMeta, "SCE" , "S"  ) ;  ENDIF
  314. IF "SCY" $ cMeta ;  cMeta := STRTRAN( cMeta, "SCY" , "S"  ) ;  ENDIF
  315. IF "CI"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CI"  , "S"  ) ;  ENDIF
  316. IF "CE"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CE"  , "S"  ) ;  ENDIF
  317. IF "CY"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CY"  , "S"  ) ;  ENDIF
  318. IF "Z"   $ cMeta ;  cMeta := STRTRAN( cMeta, "Z"   , "S"  ) ;  ENDIF
  319.  
  320. //  th sound (0)  
  321. IF "TH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "TH"  , "0"  ) ;  ENDIF
  322.  
  323. //  Convert all vowels to 'v' from 3rd byte on
  324. cMeta := LEFT( cMeta, 2 ) + _ftConvVowel( SUBSTR( cMeta, 3 ) )
  325.  
  326. // Make Y's silent if not followed by vowel
  327. IF "Y"   $ cMeta
  328.   cMeta := STRTRAN( cMeta, "Yv"  , "#"  )  // Y followed by vowel
  329.   cMeta := STRTRAN( cMeta, "Y"   , ""   )  // not followed by vowel
  330.   cMeta := STRTRAN( cMeta, "#"   , "Yv" )  // restore Y and vowel
  331. ENDIF
  332.  
  333. //  More G sounds, looking at surrounding vowels
  334. IF "GHv" $ cMeta ;  cMeta := STRTRAN( cMeta, "GHv" , "G"  ) ;  ENDIF
  335. IF "vGHT" $ cMeta;  cMeta := STRTRAN( cMeta, "vGHT", "T"  ) ;  ENDIF
  336. IF "vGH" $ cMeta ;  cMeta := STRTRAN( cMeta, "vGH" , "W"  ) ;  ENDIF
  337. IF "GN"  $ cMeta ;  cMeta := STRTRAN( cMeta, "GN"  , "N"  ) ;  ENDIF
  338. IF "G"   $ cMeta ;  cMeta := STRTRAN( cMeta, "G"   , "K"  ) ;  ENDIF
  339.  
  340. //  H sounds, looking at surrounding vowels
  341. IF "vHv" $ cMeta ;  cMeta := STRTRAN( cMeta, "vHv" , "H"  ) ;  ENDIF
  342. IF "vH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "vH"  , ""   ) ;  ENDIF
  343.  
  344. //  F sounds
  345. IF "PH"  $ cMeta ;  cMeta := STRTRAN( cMeta, "PH"  , "F"  ) ;  ENDIF
  346. IF "V"   $ cMeta ;  cMeta := STRTRAN( cMeta, "V"   , "F"  ) ;  ENDIF
  347.  
  348. //  D sounds a bit like T
  349. IF "D"   $ cMeta ;  cMeta := STRTRAN( cMeta, "D"   , "T"  ) ;  ENDIF
  350.  
  351. //  K sounds
  352. IF "CK"  $ cMeta ;  cMeta := STRTRAN( cMeta, "CK"  , "K"  ) ;  ENDIF
  353. IF "Q"   $ cMeta ;  cMeta := STRTRAN( cMeta, "Q"   , "K"  ) ;  ENDIF
  354. IF "C"   $ cMeta ;  cMeta := STRTRAN( cMeta, "C"   , "K"  ) ;  ENDIF
  355.  
  356. //  Remove vowels
  357. cMeta := STRTRAN( cMeta, "v", "" )
  358.  
  359. RETURN PadR( ALLTRIM( cMeta ), nSize )
  360.  
  361. *------------------------------------------------
  362. STATIC FUNCTION _ftMakeAlpha ( cStr )
  363. //  Strips non-alpha characters from a string, leaving spaces
  364.  
  365. LOCAL x, cAlpha := ""
  366.  
  367. FOR x := 1 to LEN( cStr )
  368.   IF SUBSTR( cStr, x, 1 ) == " " .OR. ISALPHA( SUBSTR( cStr, x, 1 ) )
  369.     cAlpha := cAlpha + SUBSTR( cStr, x, 1 )
  370.   ENDIF
  371. NEXT
  372.  
  373. RETURN cAlpha
  374.  
  375. *------------------------------------------------
  376. STATIC FUNCTION _ftConvVowel ( cStr )
  377. //  Converts all vowels to letter 'v'
  378.  
  379. LOCAL x, cConverted := ""
  380.  
  381. FOR x := 1 to LEN( cStr )
  382.   IF SUBSTR( cStr, x, 1 ) $ "AEIOU"
  383.     cConverted := cConverted + "v"
  384.   ELSE
  385.     cConverted := cConverted + SUBSTR( cStr, x, 1 )
  386.   ENDIF
  387. NEXT
  388.  
  389. RETURN cConverted
  390.  
  391. *------------------------------------------------
  392. // eof metaph.prg
  393.  
  394.